home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / MCL Networking / Network / DRIVER.lisp < prev    next >
Encoding:
Text File  |  1990-08-31  |  3.9 KB  |  104 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; Copyright 1987, 1988, 1989, 1990 by Ruben Kleiman for Apple Computer, Inc.
  3. ;;; Advanced Technology Group
  4. ;;;
  5.  
  6. ;; driver.lisp
  7. ;;
  8. ;;
  9. ;; A version of Allegro's old serial-streams.lisp
  10. ;;
  11.  
  12.  
  13. (in-package :network :use '(ccl system lisp))
  14.  
  15. (eval-when (eval load compile)
  16.   (require 'traps))
  17.  
  18. ;Some Macintosh system constants {for referencing into parameter blocks}
  19. (defconstant $IOREFNUM 24)
  20. (defconstant $IOPERMSSN 27)
  21. (defconstant $IOFILENAME 18)
  22. (defconstant $IOBUFFER 32)
  23. (defconstant $IOREQCOUNT 36)
  24. (defconstant $CSCODE 26)
  25. (defconstant $CSPARAM 28)
  26.  
  27. (proclaim '(object-variable driver-open driver-pb driver-open-p
  28.             driver-unread-char driver-name))
  29.  
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33. ;;
  34. ;;the driver object
  35. ;;
  36. ;;drivers inherit from streams (because they are used for io).
  37. ;;
  38.  
  39. (defobject *driver* *stream*)
  40.  
  41. (defobfun (exist *driver*) (init-list)
  42.   (usual-exist init-list)
  43.   (have 'driver-name (getf init-list :driver-name "Unspecified Driver"))
  44.   (have 'driver-open-p nil)
  45.   (have 'driver-pb
  46.      (_NewPtr :errchk                        ;should this be errchk? {}
  47.               :d0 (getf init-list :pb-size 80)
  48.               :a0))
  49.   (have 'driver-unread-char nil)
  50.   (%put-word driver-pb 0 $ioRefNum)          ;address, value, offset
  51.   (%put-byte driver-pb 0 $ioPermssn)         ;address, value, offset
  52.   nil)
  53.  
  54. (defobfun (driver-dispose *driver*) ()
  55.  (if driver-open-p (stream-close))           ;maybe be a continuable error? {}
  56.  (_DisposPtr :errchk :a0 driver-pb))
  57.  
  58. (defobfun (stream-open *driver*) ()
  59.   (unless driver-open-p
  60.     (stream-close)                           ;close stream just in case? {} 
  61.     (with-pstrs ((np driver-name))           ;get name string in mac format
  62.       (%put-ptr driver-pb np $ioFileName)    ;address, value, offset
  63.       (_Open :errchk :a0 driver-pb :d0))     ;open the driver
  64.     (setq driver-open-p t)))                 ;set open-p to t
  65.  
  66. (defobfun (stream-close *driver*) ()
  67.   (when driver-open-p                        ;don't close if its already closed
  68.     (_Close :errchk :a0 driver-pb :d0)       ;close the driver
  69.     (setq driver-open-p nil)))               ;set open-p to nil
  70.  
  71. (defobfun (stream-tyo *driver*) (char)       ;function for writing to stream
  72.   (%stack-block ((cp 1))                     ;make room on stack for character
  73.     (%put-byte cp char)                      ;put character there
  74.     (%put-ptr driver-pb cp $ioBuffer)        ;set up the parameter block
  75.     (%put-long driver-pb 1 $ioReqCount)      ;
  76.     (_Write :errchk :a0 driver-pb :d0)))     ;write the character
  77.  
  78. (defobfun (stream-tyi *driver*) ()           ;function for reading from stream
  79.   (when (not driver-open-p)                  ;error if driver not open
  80.     (error "Driver: ~s is not open" (self)))
  81.   (if driver-unread-char                     ;if a character has been 'unread'
  82.     (prog1 driver-unread-char                ; return it, and set unread-char
  83.            (setq driver-unread-char nil))    ; to nil
  84.     (%stack-block ((cp 2))                   ;otherwise read in a character
  85.       (%put-ptr driver-pb cp $ioBuffer)
  86.       (%put-long driver-pb 1 $ioReqCount)
  87.       (_Read :errchk :a0 driver-pb :d0)
  88.       (%get-byte cp))))
  89.  
  90. (defobfun (stream-untyi *driver*) (char)     ;function 'unreads' a character
  91.   (setq driver-unread-char char))
  92.  
  93. (defobfun (driver-control *driver*) (code)   ;{} find out what this does
  94.   (if (not driver-open-p) (error "Driver: ~s is not open" (self)))
  95.   (%put-word driver-pb code $csCode)
  96.   (_Control :errchk :a0 driver-pb))
  97.  
  98. (defobfun (driver-status *driver*) (code)    ;{} find out what this does
  99.   (if (not driver-open-p) (error "Driver: ~s is not open" (self)))
  100.   (%put-word driver-pb code $csCode)
  101.   (_Status :errchk :a0 driver-pb))
  102.  
  103. (pushnew :DRIVER *features*)
  104. (provide :driver)